00100	(CDEFUN ACHIEVE ('GOAL)
00200	   (COND ((TRUE GOAL) (RETURN 'ALREADY-TRUE))
00300	         ((TRY-NEXT (FETCHM !"(IMPERATIVE-FOR ,GOAL)))
00400	          (RETURN 'OK)))
00500	   (WRITE GOAL (FRAME)))
00600	
00700	(CDEFUN MAKE ('GOAL)
00800	   (COND ((TRY-NEXT (FETCHM !"(IMPERATIVE-FOR ,GOAL)))
00900	          (RETURN 'OK)))
01000	   (WRITE GOAL (FRAME)))
01100	
01200	(CDEFUN WRITE (GOAL FR) "AUX"(CODE POS (REASON (EXPRESSION FR)) (REJ ()))
01300	   (TERPRI)
01400	   (CPRINT !"(NEED CODE FOR ,GOAL))
01500	   (COND ((NOTICED GOAL) (CEVAL REASON) (RETURN 'OK))
01600	         ((TRY-NEXT (FETCHM !"(CODE-FOR ,GOAL !>CODE)))
01700	          (DISPLACE REASON !"(@(REASON ,REASON) ,GOAL ,CODE))
01800	          (CEVAL REASON)
01900	          (RETURN 'OK))
02000	         ((TRY-NEXT (FETCHM !"(MEANING-OF ,GOAL !>CODE)))
02100	          (CSETQ CODE !"(@(REASON ,REASON) ,GOAL
02200	                            (MEANS ,CODE (MAKE ,CODE))))
02300	          (NOTICE REASON CODE)
02400	          (CEVAL CODE)
02500	          (RETURN 'OK)))
02600	   (CSETQ POS (FETCHM !"(SUFFICES-FOR ,GOAL !>CODE)))
02700	 :SUFLP
02800	   (COND ((TRY-NEXT POS)
02900	          (COND ((TRUE CODE) (LISTEN 'LOSING-SUFCON)))
03000	          (CSETQ CODE !"(@(REASON ,REASON) ,GOAL
03100	                            (NEED-ONLY ,CODE (MAKE ,CODE))))
03200	          (NOTICE REASON CODE)
03300	          (PUTP CODE POS 'ALTSUF)
03400	          (CEVAL CODE)
03500	          (RETURN 'OK)))
03600	   (CSETQ POS (FETCHM !"(MAY-HURT ,GOAL !>CODE)))
03700	 :STRLP
03800	   (COND ((TRY-NEXT POS) (CPRINT !"(PERHAPS ,CODE))
03900	          (COND ((TRUE CODE) (PRIN1 'WORTH-A-TRY)) 
04000	                (T (PRIN1 'NOT-APPLICABLE)
04100	                 (CSETQ REJ (NCONC REJ (LIST (CADR POS))))
04200	                 (GO 'STRLP)))
04300	          (CSETQ CODE !"(@(REASON ,REASON) ,GOAL
04400	                             (STRATEGY (NOT ,CODE) (MAKE (NOT ,CODE)))))
04500	          (NOTICE REASON CODE)
04600	          (PUTP CODE (NCONC POS REJ) 'ALTSTRAT)
04700	          (CEVAL CODE)
04800	          (RETURN 'OK)))
04900	   (WORRY COULD-NOT REASON))
     

00100	
00200	(CDEFUN RAN-OUT () "AUX" ((T1 (TAG 'LP)) (EXP (EXPRESSION T1)) CODE POS (REJ ()))
00300	   (TERPRI)
00400	   (CPRINT !"(NEED ANOTHER WAY TO GET @(CADR ,EXP)))
00500	   (COND ((CSETQ POS (GETP EXP 'ALTSUF)) (CSETQ POS (CADR POS)) (GO 'SUFLP))
00600	         ((CSETQ POS (GETP EXP 'ALTSTRAT)) (CSETQ POS (CADR POS)) (GO 'STRLP)))
00700	   (CSETQ POS (FETCHM !"(SUFFICES-FOR @(CADR ,EXP) !>CODE)))
00800	 :SUFLP
00900	   (COND ((TRY-NEXT POS)
01000	          (COND ((TRUE CODE) (LISTEN 'LOSING-SUFCON)))
01100	          (CSETQ CODE !"((NEED-ONLY ,CODE (MAKE ,CODE))))
01200	          (PUTP EXP POS 'ALTSUF)
01300	          (NCONC EXP CODE)
01400	          (CSET 'CODE CODE T1)
01500	          (GO T1)))
01600	   (CSETQ POS (FETCHM !"(MAY-HURT @(CADR ,EXP) !>CODE)))
01700	 :STRLP
01800	   (COND ((TRY-NEXT POS) (CPRINT !"(RECONSIDERING ,CODE))
01900	          (COND ((TRUE CODE)(PRIN1 'WORTH-A-TRY))
02000	                (T (PRIN1  'NOT-APPLICABLE)
02100	                 (CSETQ REJ (NCONC REJ (LIST (CADR POS))))
02200	                 (GO 'STRLP)))
02300	          (CSETQ CODE !"((STRATEGY (NOT ,CODE) (MAKE (NOT ,CODE)))))
02400	          (PUTP EXP (NCONC POS REJ) 'ALTSTRAT)
02500	          (NCONC EXP CODE)
02600	          (CSET 'CODE CODE T1)
02700	          (GO T1)))
02800	   (WORRY COULD-NOT EXP))
     

00100	
00200	(DEFUN NOTICE (REASON CODE)
00300	   (PROG (P C N)
00400	      (SETQ C (CONS (CAR REASON) (CDR REASON)))
00500	      (DISPLACE REASON CODE)
00600	      (EVAL !"(IF-NEEDED @(SETQ N (GENV)) (NOTICE @(SETQ P (EXCL (CADR CODE))))
00700	                      (KILL (CAR (EXPRESSION (FRAME))))
00800	                      (CIMP @REASON @CODE @P @C)
00900	                      (ADIEU T)))
01000	      (INSERT N)))
01100	
01200	(DEFUN EXCL (P)
01300	   (COND ((ATOM P) P)
01400	         ((EQ (CAR P) '/!/,) (LIST '/!/> (CADR P)))
01500	         (T (CONS (EXCL (CAR P)) (EXCL (CDR P))))))
01600	
01700	(DEFUN CIMP FEXPR (L) (PROG (N)
01800	   (SETQ N (GENV))
01900	   (TERPRI)
02000	   (PRINT '(NOTICED POSSIBLE SUBROUTINE))
02100	   (DISPLACE (CAR L) (CADDDR L))
02200	   (SPEW (SETQ NC !"(IF-NEEDED @N (IMPERATIVE-FOR @(CADDR L))
02300		                @(CADR L)
02400		                (ADIEU T))))
02500	   (EVAL NC)
02600	   (INSERT N)))
02700	
02800	(CDEFUN NOTICED (GOAL) (TRY-NEXT (FETCHM !"(NOTICE ,GOAL))))
02900	
03000	(DEFUN REASON (R)
03100	   (COND ((EQ (CAR R) 'MAKE) 'TO-MAKE)
03200	         ((EQ (CAR R) 'ACHIEVE) 'TO-ACHIEVE)
03300	         (T (CERR REASON))))
     

00100	
00200	(COMMENT DEBUGGING)
00300	
00400	(CDEFUN BUG ('TYPE 'IRRITANT)
00500	   (CSETQ IRRITANT (!$/!"1 IRRITANT))
00600	   (CPRINT !"(BUG ,TYPE ,IRRITANT))
00700	   (TRY-NEXT (FETCHM !"(,TYPE ,IRRITANT)))
00800	   (LISTEN  !"(DO NOT KNOW HOW TO DEBUG ,TYPE)))
00900	
01000	(IF-NEEDED BUG-U-P (UNSATISFIED-PREREQUISITE !>X)
01100	   (CSETQ ORIG (FRAME))
01200	   (NEEDBACK))
01300	
01400	(CDEFUN NEEDBACK () "AUX"((N (VFRAME 'NECESSARY)))
01500	   (COND (N (CEVAL '(GO 'BACK) N))
01600	         (T (LISTEN 'UNDECLARED-PREREQUISITE--ORIG))))
01700	
01800	(CDEFUN SCREWED ()
01900	   (LISTEN 'PREREQUISITE-LOST-BETWEEN-HERE-AND-ORIG))
02000